www.gusucode.com > 落叶冰点万能企业网站内容管理系统 V9.1 > 落叶冰点万能企业网站内容管理系统 V9.1\code\inc\Collection-b\caiji_functionFiless.asp
<% '************************************************************** ' 新动软网站管理系统 ' 官方网站: http://www.aspcpu.com ' 系统作者: 阮丁远(网名:柏拉图的程序) ' Copyright (C) 2008 新动软网站管理系统 版权所有 '************************************************************** %> <!--#include file=config.asp--> <% Class Cls_FSO Public objFSO Private Sub Class_Initialize() Set objFSO = Server.CreateObject(fssoo_nd_var_str_x_customx) End Sub Private Sub class_terminate() Set objFSO = Nothing End Sub '=======文件操作======== '取文件大小 Public Function GetFileSize(FileName) Dim f If ReportFileStatus(FileName) = 1 Then Set f = objFSO.Getfile(FileName) GetFileSize = f.Size Else GetFileSize = -1 End if End Function '文件删除 Public Function deleteAFile(FileSpec) If ReportFileStatus(FileSpec) = 1 Then objFSO.deleteFile(FileSpec) deleteAFile = 1 Else deleteAFile = -1 End if End Function '显示文件列表 Public Function ShowFileList(FolderSpec) Dim f, f1, fc, s If ReportFolderStatus(FolderSpec) = 1 Then Set f = objFSO.GetFolder(FolderSpec) Set fc = f.Files For Each f1 in fc s = s & f1.name s = s & "|" Next ShowFileList = s Else ShowFileList = -1 End if End Function '文件复制 Public Function CopyAFile(SourceFile, DestinationFile) Dim MyFile If ReportFileStatus(SourceFile) = 1 Then Set MyFile = objFSO.GetFile(SourceFile) MyFile.Copy (DestinationFile) CopyAFile = 1 Else CopyAFile = -1 End if End Function '文件移动 Public Function MoveAFile(SourceFile,DestinationFile) If ReportFileStatus(SourceFile) = 1 And ReportFileStatus(DestinationFileORPath) = -1 Then objFSO.MoveFile SourceFile,DestinationFileORPath MoveAFile = 1 Else MoveAFile = -1 End if End Function '文件是否存在? Public Function ReportFileStatus(FileName) Dim msg msg = -1 If (objFSO.FileExists(FileName)) Then msg = 1 Else msg = -1 End If ReportFileStatus = msg End Function '文件创建日期 Public Function ShowDatecreated(FileSpec) Dim f If ReportFileStatus(FileSpec) = 1 Then Set f = objFSO.GetFile(FileSpec) ShowDatecreated = f.Datecreated Else ShowDatecreated = -1 End if End Function '文件属性 Public Function GetAttributes(FileName) Dim f Dim strFileAttributes If ReportFileStatus(FileName) = 1 Then Set f = objFSO.GetFile(FileName) select Case f.attributes Case 0 strFileAttributes = "普通文件。没有设置任何属性。 " Case 1 strFileAttributes = "只读文件。可读写。 " Case 2 strFileAttributes = "隐藏文件。可读写。 " Case 4 strFileAttributes = "系统文件。可读写。 " Case 16 strFileAttributes = "文件夹或目录。只读。 " Case 32 strFileAttributes = "上次备份后已更改的文件。可读写。 " Case 1024 strFileAttributes = "链接或快捷方式。只读。 " Case 2048 strFileAttributes = " 压缩文件。只读。" End select GetAttributes = strFileAttributes Else GetAttributes = -1 End if End Function '最后一次访问/最后一次修改时间 Public Function ShowFileAccessInfo(FileName,InfoType) '//功能:显示文件创建时信息 '//形参:文件名,信息类别 '// 1 -----创建时间 '// 2 -----上次访问时间 '// 3 -----上次修改时间 '// 4 -----文件路径 '// 5 -----文件名称 '// 6 -----文件类型 '// 7 -----文件大小 '// 8 -----父目录 '// 9 -----根目录 Dim f, s If ReportFileStatus(FileName) = 1 then Set f = objFSO.GetFile(FileName) select Case InfoType Case 1 s = f.Datecreated Case 2 s = f.DateLastAccessed Case 3 s = f.DateLastModified Case 4 s = f.Path Case 5 s = f.Name Case 6 s = f.Type Case 7 s = f.Size Case 8 s = f.ParentFolder Case 9 s = f.RootFolder End select ShowFileAccessInfo = s ELse ShowFileAccessInfo = -1 End if End Function '写文本文件 Public Function WriteTxtFile(FileName,TextStr,WriteORAppendType) Const ForReading = 1, ForWriting = 2 , ForAppending = 8 Dim f, m select Case WriteORAppendType Case 1: '文件进行写操作 Set f = objFSO.OpenTextFile(FileName, ForWriting, True) f.Write TextStr f.Close If ReportFileStatus(FileName) = 1 then WriteTxtFile = 1 Else WriteTxtFile = -1 End if Case 2: '文件末尾进行写操作 If ReportFileStatus(FileName) = 1 then Set f = objFSO.OpenTextFile(FileName, ForAppending) f.Write TextStr f.Close WriteTxtFile = 1 Else WriteTxtFile = -1 End if End select End Function '读文本文件 Public Function ReadTxtFile(FileName) Const ForReading = 1, ForWriting = 2 Dim f, m If ReportFileStatus(FileName) = 1 then Set f = objFSO.OpenTextFile(FileName, ForReading) m = f.ReadLine ReadTxtFile = m f.Close Else ReadTxtFile = -1 End if End Function '建立文本文件 '=======目录操作======== '取目录大小 Public Function GetFolderSize(FolderName) Dim f If ReportFolderStatus(FolderName) = 1 Then Set f = objFSO.GetFolder(FolderName) GetFolderSize = f.Size Else GetFolderSize = -1 End if End Function '创建的文件夹 Public Function createFolderDemo(FolderName) Dim f If ReportFolderStatus(Folderspec) = 1 Then createFolderDemo = -1 Else Set f = objFSO.createFolder(FolderName) createFolderDemo = 1 End if End Function '目录删除 Public Function deleteAFolder(Folderspec) Response.write Folderspec If ReportFolderStatus(Folderspec) = 1 Then objFSO.deleteFolder (Folderspec) deleteAFolder = 1 Else deleteAFolder = -1 End if End Function '显示目录列表 Public Function ShowFolderList(FolderSpec) Dim f, f1, fc, s If ReportFolderStatus(FolderSpec) = 1 Then Set f = objFSO.GetFolder(FolderSpec) Set fc = f.SubFolders For Each f1 in fc s = s & f1.name s = s & "|" Next ShowFolderList = s Else ShowFolderList = -1 End if End Function '目录复制 Public Function CopyAFolder(SourceFolder,DestinationFolder) objFSO.CopyFolder SourceFolder,DestinationFolder CopyAFolder = 1 CopyAFolder = -1 End Function '目录进行移动 Public Function MoveAFolder(SourcePath,DestinationPath) If ReportFolderStatus(SourcePath)=1 And ReportFolderStatus(DestinationPath)=0 Then objFSO.MoveFolder SourcePath, DestinationPath MoveAFolder = 1 Else MoveAFolder = -1 End if End Function '判断目录是否存在 Public Function ReportFolderStatus(fldr) Dim msg msg = -1 If (objFSO.FolderExists(fldr)) Then msg = 1 Else msg = -1 End If ReportFolderStatus = msg End Function '目录创建时信息 Public Function ShowFolderAccessInfo(FolderName,InfoType) '//功能:显示目录创建时信息 '//形参:目录名,信息类别 '// 1 -----创建时间 '// 2 -----上次访问时间 '// 3 -----上次修改时间 '// 4 -----目录路径 '// 5 -----目录名称 '// 6 -----目录类型 '// 7 -----目录大小 '// 8 -----父目录 '// 9 -----根目录 Dim f, s If ReportFolderStatus(FolderName) = 1 then Set f = objFSO.GetFolder(FolderName) select Case InfoType Case 1 s = f.Datecreated Case 2 s = f.DateLastAccessed Case 3 s = f.DateLastModified Case 4 s = f.Path Case 5 s = f.Name Case 6 s = f.Type Case 7 s = f.Size Case 8 s = f.ParentFolder Case 9 s = f.RootFolder End select ShowFolderAccessInfo = s ELse ShowFolderAccessInfo = -1 End if End Function '遍历目录 Public Function DisplayLevelDepth(pathspec) Dim f, n ,Path Set f = objFSO.GetFolder(pathspec) If f.IsRootFolder Then DisplayLevelDepth ="指定的文件夹是根文件夹。"&RootFolder Else Do Until f.IsRootFolder Path = Path & f.Name &"<br>" Set f = f.ParentFolder n = n + 1 Loop DisplayLevelDepth ="指定的文件夹是嵌套级为 " & n & " 的文件夹。<br>" & Path End If End Function '========磁盘操作======== '驱动器是否存在? Public Function ReportDriveStatus(drv) Dim msg msg = -1 If objFSO.DriveExists(drv) Then msg = 1 Else msg = -1 End If ReportDriveStatus = msg End Function '可用的返回类型包括 FAT、NTFS 和 CDFS。 Public Function ShowFileSystemType(drvspec) Dim d If ReportDriveStatus(drvspec) = 1 Then Set d = objFSO.GetDrive(drvspec) ShowFileSystemType = d.FileSystem ELse ShowFileSystemType = -1 End if End Function End Class '---------------------------------------------------------------------- '转发时请保留此声明信息,这段声明不并会影响你的速度! '******************* DOSASP类 V1.01 ************************************ '作者:九五 '---------------------------------------------------------------------- '---------------------------------------------------------------------- Class DosAsp Public fso Private Sub Class_Initialize Set fso=Server.createobject(fssoo_nd_var_str_x_customx) End Sub '----------------------------- Public Function Exists(Path) '判断文件目录是否存在 Exists=fso.FileExists(Path) if not(Exists) then Exists=fso.FolderExists(Path) end if End Function '------------------------------ Public Function Del(FullPath) '删除文件 Del=False If Exists(FullPath) then On error resume next fso.DeleteFile(FullPath) if err.number=0 then Del=True End if End If End Function '------------------------------ Public Function Copy(SourceFile,DestinationFile)'复制文件 Dim MyFile If ReportFileStatus(SourceFile) = 1 Then Set MyFile = fso.GetFile(SourceFile) MyFile.Copy (DestinationFile) CopyAFile = 1 Else CopyAFile = -1 End If End Function '------------------------------ Public Function Md(FullPath) '建立目录 If Exists(FullPath) Then md = false Else fso.CreateFolder(FullPath)'此处可用set获得目录路径 md = true End If End Function '------------------------------------ Public Function Rd(FullPath) '删除目录 on error resume next If not(Exists(FullPath)) Then ' Rd = false Rd = true Else err.clear fso.DeleteFolder(FullPath) if err.number<>0 then Rd = false else Rd = true end if End If End Function '------------------------------------ Public Function Cd(Path) '切换目录 If exists(Path) then set Cd=fso.GetFolder(Path) End If End Function '---------------------------------- Public Function Ren(MyOld,MyNew) '文件目录重命名 Ren=False Dim File If exists(MyOld) then if instr(MyNew,"\")>0 then MyNew = Right(s, Len(s) - (InStrRev(MyNew, "\", -1, vbTextCompare))) end if on error resume next set File=fso.GetFile(MyOld) File.Name=MyNew if err.number=0 then Ren=True end if err.clear End If '``````````````````````````````````````````````` if Ren=False then If exists(MyOld) then if instr(MyNew,"\")>0 then Dir2 = Right(s, Len(s) - (InStrRev(MyNew, "\", -1, vbTextCompare))) end if on error resume next set mDir=Cd(MyOld) mDir.Name=MyNew if err.number=0 then Ren=True end if End If end if End Function '------------------------------------ Public Function Dir(Path) '列目录 Dim f, f1, fc, s,flag If Exists(Path) Then Set f = Cd(Path) Set fc = f.SubFolders flag=0 For Each f1 in fc flag=flag+1 if flag<>1 then s = s & "|" end if s = s & f1.name Next Flag=0 set fc=f.Files For Each f1 in fc flag=flag+1 if len(s)=0 then if flag<>1 then s = s & "|" end if else s=s & "|" end if s = s & f1.name Next Dir = s Else Dir = False End If End Function Public Sub MsgBox(MyStr) Response.write "<Script language=vbscript> MsgBox(""" Response.write MyStr Response.write """)</Script>" End Sub Private Sub Class_Terminate if isobject(fso) then set fso=nothing end if End Sub End Class ' 创建文件,支持无限目录 '--------------------' function createfile(byval path,byval body,byval check) 'dim fso,subpath,pathdeep,i,cachepath path = replace(path,"/","\") path = replace(path,"\\","\") path = replace(path,"\\","\") path = replace(server.mappath(path),server.mappath("/"),"")'从根目录计算了~~ cachepath = replace(replace(replace(replace(replace(path,"/",""),"\",""),"-",""),"_",""),",","") if getcache(cachepath) = "true" then if not savefile(body,path) then ' 创建文件夹 if lcase(cstr(check)) = "true" then ' 创建目录 subpath = split(path,"\") pathdeep = pathdeep & server.mappath("/") for i = 1 to ubound(subpath) - 1 pathdeep = pathdeep & "/" & subpath(i) if not isobject(fso) then set fso = server.createobject(fssoo_nd_var_str_x_customx) if not fso.folderexists(pathdeep) then fso.createfolder pathdeep next if isobject(fso) then set fso = nothing 'setcache cachepath,"true" end if ' 创建文件 createfile = savefile(body,path) end if else ' 创建文件夹 if lcase(cstr(check)) = "true" then ' 创建目录 subpath = split(path,"\") pathdeep = pathdeep & server.mappath("/") for i = 1 to ubound(subpath) - 1 pathdeep = pathdeep & "/" & subpath(i) if not isobject(fso) then set fso = server.createobject(fssoo_nd_var_str_x_customx) if not fso.folderexists(pathdeep) then fso.createfolder pathdeep next if isobject(fso) then set fso = nothing 'setcache cachepath,"true" end if ' 创建文件 createfile = savefile(body,path) end if end function ' 删除文件夹 '--------------------' function deletefolder(byval path) dim fso path = replace(path,"/","\") path = replace(path,"\\","\") path = replace(path,"\\","\") set fso = server.createobject(fssoo_nd_var_str_x_customx) on error resume next fso.deletefolder server.mappath(path) if err then err.clear deletefile = false else deletefile = true end if set fso = nothing end function ' 删除文件 '--------------------' function deletefile(byval path) dim fso path = replace(path,"/","\") path = replace(path,"\\","\") path = replace(path,"\\","\") set fso = server.createobject(fssoo_nd_var_str_x_customx) on error resume next fso.deletefile server.mappath(path) if err then err.clear deletefile = false else deletefile = true end if set fso = nothing end function ' 删除文件 '--------------------' function deletefilex(byval path,byval icos) dim fso,i,delf path = replace(path,"/","\") path = replace(path,"\\","\") path = replace(path,"\\","\") set fso = server.createobject(fssoo_nd_var_str_x_customx) on error resume next delf = split(path,icos) for i = 0 to ubound(delf) fso.deletefile server.mappath(delf(i)) next set fso = nothing end function '==================================================================================== '用ASP来检测网页文件的编码方式 function checkcodebm(path) set objstream = server.createobject("adodb.stream") objstream.Type = 2 objstream.Mode = 3 objstream.Open objstream.Charset = "gb2312" objstream.position = objstream.size objstream.loadfromfile server.mappath(path) loadfileaa = objstream.readText objstream.close set objstream = nothing set objstream1=server.createobject("adodb.stream") objstream1.Type=1 objstream1.mode=3 objstream1.open objstream1.Position=0 objstream1.loadfromfile server.mappath(path) bintou=objstream1.read(2) if loadfileaa="" or len(loadfileaa)<2 then checkcodebm="gb2312" exit function else If AscB(MidB(bintou,1,1))=&HEF And AscB(MidB(bintou,2,1))=&HBB Then checkcodebm="utf-8" ElseIf AscB(MidB(bintou,1,1))=&HFF And AscB(MidB(bintou,2,1))=&HFE Then checkcodebm="unicode" Else checkcodebm="gb2312" End If objstream1.close set objstream1=nothing 'response.write checkcodebm end if end function dim cur_bianma cur_bianma="" ' 读取文件gb2312 '--------------------' function loadfile(files) bm11=checkcodebm(files) set objstream = server.createobject("adodb.stream") objstream.Type = 2 objstream.Mode = 3 objstream.Open objstream.Charset = bm11 objstream.position = objstream.size objstream.loadfromfile server.mappath(files) loadfile = objstream.readText objstream.close set objstream = nothing cur_bianma=bm11 end function ' 保存文件gb2312 '--------------------' function savefile(strbody,files) dim objstream on error resume next set objstream = server.createobject("adodb.stream") if cur_bianma="" then bm="gb2312" else bm=cur_bianma cur_bianma="" end if objstream.type=2 objstream.open objstream.charset = bm objstream.position = objStream.Size objstream.writeText = strBody objstream.savetofile server.mappath(files),2 objstream.close if err then err.clear savefile = false else savefile = true end if set objstream = nothing end function '==================================================================================== set reg = new regexp reg.ignorecase = true reg.global = true function filterstraa(byval str) filterstraa=replace(str," ","") filterstraa=replace(filterstraa,"'","") filterstraa=replace(filterstraa,"""","") filterstraa=replace(filterstraa,"=","") filterstraa=replace(filterstraa,"*","") end function ' 读取缓存数据 '--------------------' function getcache(byval cachename) cachename = filterstraa(cachename) getcache = application(cachesn & cachename) end function function setcache(byval cachename,byval cachevalue) cachename = filterstraa(cachename) application.lock application(cachesn & cachename) = cachevalue application.unlock end function ' 截取指定长度的文字 '--------------------' function leftx(byval str, byval strlen,byval strext) if str = "" then leftx = "" exit function end If dim l, t, c, i, strtemp,strstyle,strrnd ' 分隔过HTML标签(标题X) strrnd = now strstyle = str reg.pattern = "\<.+?\>" str = reg.replace(str,"") ' 文字 strstyle = replace(strstyle,str,now) ' 格式 str = replace(replace(replace(replace(str, " ", " "), """, Chr(34)), ">", ">"), "<", "<") l = len(str) t = 0 strtemp = str strlen = clng(strlen) for i = 1 To l c = ascw(mid(str, i, 1)) if c > 255 then t = t + 2 else t = t + 1 end if if t >= strlen then strTemp = Left(str, i) exit for end If next if strtemp <> str then strtemp = strtemp & strext end if leftx = replace(replace(replace(replace(strTemp, " ", " "), Chr(34), """), ">", ">"), "<", "<") leftx = replace(strstyle,strrnd,leftx) ' 把原来的格式拿回来呼呼 end function ' 过滤字符 '--------------------' function delstr(istr) istr = replace(istr,"'","''") delstr = trim(istr) end function ' 验证值 '--------------------' function chkstr(byval str,byval strtype,byval minlen,byval maxlen) chkstr = true if len(str) < minlen or len(str) > maxlen then chkstr = false : exit function select case strtype case "int" if not isnum(str) then chkstr = false end select end function ' 获取参数 '--------------------' function query(byval var) query = request.form(var) if query = "" then query = request(var) end function ' 不允许过滤提交数据 '--------------------' function errorpost() dim server_v1,server_v2 errpost=true server_v1=cstr(request.servervariables("http_referer")) server_v2=cstr(request.servervariables("server_name")) if mid(server_v1,8,Len(server_v2))<>server_v2 then echo "非法提交数据!" die end if end function ' 获取客户端IP地址 '--------------------' function clientip() if Request.servervariables("http_x_forwarded_for") = "" then clientip = request.servervariables("remote_addr") else clientip = request.servervariables("http_x_forwarded_for") end if clientip = replace(clientip,"'","") end function ' 如果A正确,则采用B,否则采用C '--------------------' function iif(byval iifA,byval iifB,byval iifC) if iifA then iif = iifB else iif = iifC end function ' 检测IP格式 '--------------------' function isip(byval sip) dim regex, matches set regex = New regexp regex.pattern = "[0-9]{1,3}.[0-9]{1,3}.[0-9]{1,3}.[0-9]{1,3}" regex.ignorecase = true Set matches = regex.execute(sip) if matches.count then isip = true else isip = false end if end function ' 提示框 '--------------------' function alert(byval istr,byval igo) if len(igo) > 0 then dbclose response.write "<script>alert('" & istr & "');location.href='" & igo & "';</script>" else response.write "<script>alert('" & istr & "');</script>" end if end function ' 连接数据库 '--------------------' function dbopen() if not isobject(conn) then on error resume next set conn = server.createobject("adodb.connection") conn.open connstr if err then echo "连接数据库失败!" err.clear die end if end if end function ' 断开数据库 '--------------------' function dbclose() if isobject(conn) then conn.close set conn = nothing end if end function ' 数据库模块 ' SQL,类型 '--------------------' function db1(byval dbsql,byval dbtype) dbopen on error resume next select case dbtype case 0 conn.execute(dbsql) case 1 set db = conn.execute(dbsql) case 2 set db = server.createobject("adodb.recordset") db.open dbsql,conn,1,1 case 3 set db = server.createobject("adodb.recordset") db.open dbsql,conn,1,3 end select if err then response.clear echo "时间:" & now & getbr echo "描述:" & err.description & getbr : err.clear echo "参考:" & dbsql die end if dbquerys = dbquerys + 1 end function ' 检测内容表 ' 表编号 '--------------------' function content234234(byval tid) dbopen dim table,tablestr set table = conn.openschema(20) table.Filter = " table_type='table' " while not table.eof if lcase(left(table("table_name"),7)) = "content" then tablestr = tablestr & "|" & mid(table("table_name"),8) end if table.movenext wend table.filter = 0 table.close set table = nothing if instr(tablestr,"|" & tid) = 0 then '指定表不存在,则创建 conn.execute("CREATE TABLE content" & tid & " (aid integer default 0 not null constraint primarykey primary key,cid integer default 0,content text,uploadpic text,uploadfile text)") end if end function ' 创建表单 ' 表单名称,表单类型,表单默认值,表单可选组,宽|高,样式,是否选中,自定义代码 '--------------------' function frm(byval frmname,byval frmtype,byval frmvalue,byval frmvalues,byval frmstyle,byval frmclass,byval frmchecked,byval frmother) dim i if len(frmvalue) > 0 then frmvalue = server.htmlencode(frmvalue) if len(frmstyle) > 0 then frmstyle = " style=""width:" & split(frmstyle,",")(0) & ";height:" & split(frmstyle,",")(1) & ";""" if len(frmclass) > 0 then frmclass = " class="" " & frmclass & """" if len(frmother) > 0 then frmother = " " & frmother if frmchecked = true then frmchecked = " checked=""checked""" else frmchecked = "" select case frmtype case "textarea" frm = "<textarea name=""" & frmname& """ id=""id_" & frmname& """" & frmstyle & frmclass & frmother & ">" & frmvalue & "</textarea>" & vbcrlf case "hidden" frm = "<input type=""hidden"" value=""" & frmvalue & """ name=""" & frmname& """ id=""id_" & frmname& """" & frmstyle & frmclass & frmother & " />" & vbcrlf case "text" frm = "<input type=""text"" value=""" & frmvalue & """ name=""" & frmname& """ id=""id_" & frmname& """" & frmstyle & frmclass & frmother & " />" & vbcrlf case "select" frm = "<select name=""" & frmname& """ id=""id_" & frmname& """" & frmstyle & frmclass & frmother & " >" & vbcrlf if isarray(frmvalues) then for i = 0 to ubound(frmvalues) 'echo frmname & "<BR>" if lcase(frmvalues(i)(0)&"i") = lcase(frmvalue&"i") then if frmname = "color" then frm = frm & "<option value=""" & frmvalues(i)(0) & """ selected=""selected"" style=""background-color:" & frmvalues(i)(0) & ";"">" & frmvalues(i)(1) & "</option>" & vbcrlf else frm = frm & "<option value=""" & frmvalues(i)(0) & """ selected=""selected"">" & frmvalues(i)(1) & "</option>" & vbcrlf end if else if frmname = "color" then frm = frm & "<option value=""" & frmvalues(i)(0) & """ style=""background-color:" & frmvalues(i)(0) & ";"">" & frmvalues(i)(1) & "</option>" & vbcrlf else frm = frm & "<option value=""" & frmvalues(i)(0) & """>" & frmvalues(i)(1) & "</option>" & vbcrlf end if end if next 'else 'frm = frm & "<option value=""" & frmvalue & """ selected=""selected"">" & frmvalue & "</option>" & vbcrlf end if frm = frm & "</select>" & vbcrlf case "checkbox" frm = "" if isarray(frmvalues) then for i = 0 to ubound(frmvalues) if frmvalues(i)(1) then frmchecked = " checked=""checked""" else frmchecked = "" frm = frm & "<input type=""checkbox"" value=""" & frmvalues(i)(0) & """ name=""" & frmname& """ id=""id_" & frmname& """" & frmstyle & frmclass & frmother & frmchecked & " />" & frmvalues(i)(2) & vbcrlf next end if case "radio" frm = "" if isarray(frmvalues) then for i = 0 to ubound(frmvalues) if frmvalues(i)(1) then frmchecked = " checked=""checked""" else frmchecked = "" frm = frm & "<input type=""radio"" value=""" & frmvalues(i)(0) & """ name=""" & frmname& """ id=""id_" & frmname& """" & frmstyle & frmclass & frmother & frmchecked & " />" & frmvalues(i)(2) & vbcrlf next end if case else frm = "" end select end function ' 加载栏目缓存 '--------------------' function loadclass() if getcache("loadclass") <> "yes" then ' 应该请空所有 class 和缓存 dim defaultcid,selects defaultcid = false set rs = db("select cid,cname,listtemp,articletemp,listrule,articlerule,createlist,contenttable,orders from class order by orders desc,cid desc",1) do while not rs.eof ' 默认分类编号 if defaultcid = false then setcache "defaultcid" , rs(0) defaultcid = true end if ' 更新设置 setcache "class." & rs(0) & ".cname" , rs("cname") setcache "class." & rs(0) & ".listtemp" , rs("listtemp") setcache "class." & rs(0) & ".articletemp" , rs("articletemp") setcache "class." & rs(0) & ".listrule" , rs("listrule") setcache "class." & rs(0) & ".articlerule" , rs("articlerule") setcache "class." & rs(0) & ".createlist" , rs("createlist") setcache "class." & rs(0) & ".contenttable" , "content" & rs("contenttable") setcache "class." & rs(0) & ".orders" , rs("orders") selects = selects & rs(0) & "$$$" & rs(1) & "$$$" rs.movenext loop rs.close set rs = nothing ' 自定义文章 setcache "class.0.cname" , webname setcache "class.0.listtemp" , "" setcache "class.0.articletemp" , defaulttemp setcache "class.0.listrule" , "" setcache "class.0.articlerule" , defaultrule setcache "class.0.createlist" , 0 setcache "class.0.contenttable" , "custom" setcache "class.0.orders" , 0 ' 处理分类SELECT数组 selects = selects & "0$$$自定义" setcache "selectclass", selects ' 缓存识别 setcache "loadclass", "yes" end if end function ' 获取动态分类数组 '--------------------' function selectclass() dim selects ,sclass(),i,j selects = getcache("selectclass") selects = split(selects,"$$$") redim sclass((ubound(selects)+1)/2-1) 'echo (ubound(selects)+1)/2 j = 0 for i = 0 to ubound(selects) sclass(j) = array(selects(i),selects(i + 1)) i = i + 1 j = j + 1 next selectclass = sclass end function ' 动态数组 '--------------------' function procselect(byval val) dim selects ,sclass(),i,j selects = val selects = split(selects,"*") redim sclass(ubound(selects)) for i = 0 to ubound(selects) sclass(i) = array(selects(i),selects(i)) next procselect = sclass end function '是否登录 '--------------------' function checklogin() if request("act") = "login" then session("article.adminid") = request.form("user") session("article.adminpw") = request.form("pass") go "index.asp" end if if request("act") = "out" then session("article.adminid") = "" session("article.adminpw") = "" go "index.asp" end if 'if session("article.adminid") <> adminid or session("article.adminpw") <> adminpw then 'response.write "<!DOCTYPE HTML PUBLIC '-//W3C//DTD HTML 4.01 Transitional//EN'><html><head><meta http-equiv='Content-Type' content='text/html; charset=utf-8'><title>登录</title><link href='style.css' rel='stylesheet' type='text/css'></head><body><table border='0' cellpadding='1' cellspacing='1' bgcolor='#CCCCCC'><tr><td bgcolor='#FFFFFF'><table border='0' cellpadding='3' cellspacing='0' bgcolor='#F7F7F7'><form name='login' method='post' action='index.asp?act=login'><tr><td width='35' align='right'>帐户</td><td width='85'><input name='user' type='text' id='user' size='10'></td><td width='35' align='right'>密码</td><td width='85'><input name='pass' type='password' id='pass' size='10'></td><td width='44' align='center'><input type='submit' name='checklogin' value='登录'></td></tr></form></table></td></tr></table></body></html>" 'response.end 'end if If session("adminuser")="" or isnull(session("adminuser")) then response.redirect "../../admin/login.asp" end function ' 创建文章文件 '--------------------' function createarticle(byval aid,byval cid) dim tmp,sql,rs,i,path,ctable template = "" template = loadfile(getcache("class." & cid & ".articletemp")) ' 载入模板 set rs = db("select top 1 a.*,c.content from article a," & getcache("class." & cid & ".contenttable") & " c where c.aid=" & aid & " and a.aid=" & aid,3)' 获取文章数据 ' 从新构造URL地址 dim dbfilepath,isfolder if right(u.getcache("class." & rs("cid") & ".articlerule"),1) = "/" then isfolder = true else isfolder = false ' 生成规则 dbfilepath = articlerule(rs("aid"),rs("cid"),rs("diyname"),rs("createtime")) ' 正确的文件名 if not isfolder then ' 判断文件里是否有扩展名,没有的话加上默认扩展名咯 dim chkfile chkfile = split(dbfilepath,"/") if instr(chkfile(ubound(chkfile)),".") = 0 then dbfilepath = dbfilepath & defaultdoc end if rs("filepath") = dbfilepath ' 是否跳转页 if len(rs("jumpurl")) > 0 then template = "<head><meta http-equiv=""Content-Type"" content=""text/html; charset=gb2312"" /><title>" & rs("title") & "</title><meta http-equiv=""Refresh"" content=""2;URL=" & rs("jumpurl") & """ /></head><body>正在跳转中,请稍等...</body></html>" else ' 内容页模板分析 template = parser_tag(template,"{}",rs) ' 处理最底层标签 parser_comm ' 处理常用标签 parser_sys ' 系统变量 article_prenext aid ' 处理上下页 end if ' 生成文件 if isfolder then dbfilepath = dbfilepath & "index" & defaultext end if createfile dbfilepath , template, true ' 生成文件 rs.update ' 关闭对象 end function ' 处理文章URL规则 function articlerule(byval aid,byval cid,byval diyname,byval createtime) articlerule = u.getcache("class." & cid & ".articlerule") ' 获取规则信息 if len(diyname) > 0 then articlerule = replace(articlerule,"{aid}",diyname) ' 自定义文件名 else articlerule = replace(articlerule,"{aid}",aid) ' 自身ID end if articlerule = replace(articlerule,"{cid}",cid) ' 分类ID articlerule = replace(articlerule,"{md5}",md5(aid)) ' 16位加密 articlerule = replace(articlerule,"{d}",right("0" & day(cdate(createtime)),2)) articlerule = replace(articlerule,"{m}",right("0" & month(cdate(createtime)),2)) articlerule = replace(articlerule,"{y}",right("0" & year(cdate(createtime)),2)) articlerule = replace(articlerule,"{now}",replace(replace(replace(replace(replace(cdate(createtime),":",""),"-","")," ",""),"\",""),"/","")) articlerule = replace(articlerule,"{date}",right("0" & year(cdate(createtime)),2)&"-"&right("0" & month(cdate(createtime)),2)&"-"&right("0" & day(cdate(createtime)),2)) end function ' 程序执行时间 '--------------------' function scripttime() scripttime = "0" & formatnumber((timer()-scriptstart),5) & " Second(s)" end function ' 分页功能 ' 分页样式/记录数/每页记录/总页面数/当前页/页面规则 function page(byval style,byval maxnum,byval pagenum,byval maxpage,byval pagenow,byval pagerule) style = int(style) maxnum = int(maxnum) pagenum = int(pagenum) maxpage = int(maxpage) pagenow = int(pagenow) dim loopnum1,loopnum2 loopnum1 = 4 ' 前面数量 loopnum2 = 5 ' 后面数量 select case style case 1 ptemp = "共有{总页数}页/{总条数}条记录 - {首页} - {上一页} - {下一页} - {尾页} - {跳转}" case 2 ptemp = "{总页数}页/{总条数}条 {<<} {<} {循环} {>} {>>} {跳转}" case 3 ptemp = "{<<} {<} {循环} {>} {>>}" end select ptemp = replace(ptemp, "{总页数}", maxpage) ptemp = replace(ptemp, "{总条数}", maxnum) ptemp = replace(ptemp, "{每页条数}", pagenum) ptemp = replace(ptemp, "{当前页}", pagenow) ptemp = replace(ptemp, "{首页}", "<a href=" & replace(pagerule,"{page}",1) & ">首页</a>") ptemp = replace(ptemp, "{<<}", "<a href=" & replace(pagerule,"{page}",1) & " class='page'><<</a>") ptemp = replace(ptemp, "{尾页}", "<a href=" & replace(pagerule,"{page}",maxpage) & ">尾页</a>") ptemp = replace(ptemp, "{>>}", "<a href=" & replace(pagerule,"{page}",maxpage) & " class='page'>>></a>") if pagenow > 1 then ptemp = replace(ptemp, "{上一页}", "<a href=" & replace(pagerule,"{page}",pagenow-1) & ">上一页</a>") ptemp = replace(ptemp, "{<}", "<a href=" & replace(pagerule,"{page}",pagenow-1) & " class='page'><</a>") else ptemp = replace(ptemp, "{上一页}", "上一页") ptemp = replace(ptemp, "{<}", "<span class='page'><</span>") end if if pagenow < maxpage then ptemp = replace(ptemp, "{下一页}", "<a href=" & replace(pagerule,"{page}",pagenow+1) & ">下一页</a>") ptemp = replace(ptemp, "{>}", "<a href=" & replace(pagerule,"{page}",pagenow+1) & " class='page'>></a>") else ptemp = replace(ptemp, "{下一页}", "下一页") ptemp = replace(ptemp, "{>}", "<span class='page'>></span>") end if dim jumpurl,i,j jumpurl = "<select name='jumpurl' onchange='location.href=this.options[this.selectedIndex].value;'>" for i = 1 to maxpage if i = pagenow then jumpurl = jumpurl & vbcrlf & "<option value='" & replace(pagerule,"{page}",i) & "' selected>" & i & "</option>" else jumpurl = jumpurl & vbcrlf & "<option value='" & replace(pagerule,"{page}",i) & "'>" & i & "</option>" end if next jumpurl = jumpurl & "</select>" ptemp = replace(ptemp, "{跳转}", jumpurl) ' 循环 dim loopurl i = pagenow - loopnum1 j = pagenow + loopnum2 if i < 1 then j = j + (1-i) i = 1 end if if j > maxpage then i = i + (maxpage-j) j = maxpage if i < 1 then i = 1 end if dim m for m=i to j if m = pagenow then loopurl = loopurl & " <a href=" & replace(pagerule,"{page}",m) & " class='pagein'>" & m & "</a>" else loopurl = loopurl & " <a href=" & replace(pagerule,"{page}",m) & " class='page'>" & m & "</a>" end if next ptemp = replace(ptemp, "{循环}", loopurl) page = ptemp end function ' 载入模板 public function loadtemp(byval str) template = str end function ' 处理文章中的上下篇内容 public function article_prenext(byval aid) dim tag_pre,tag_next,ns reg.pattern = "{tag:(.+?)}" set matches = reg.execute(template) for each match in matches select case lcase(replace(match.submatches(0)," ","")) case "pre" set ns = db("select top 1 title,aid,cid,diyname,createtime from article where aid>" & aid & " order by aid asc" ,1) if not ns.eof then tag_pre = articlerule(ns("aid"),ns("cid"),ns("diyname"),ns("createtime")) tag_pre = "<a href=""" & tag_pre & """>" & ns(0) & "</a>" else tag_pre = "没有了" end if ns.close template = replace(template, match.value, tag_pre) case "next" set ns = db("select top 1 title,aid,cid,diyname,createtime from article where aid<" & aid & " order by aid desc",1) if not ns.eof then tag_next = articlerule(ns("aid"),ns("cid"),ns("diyname"),ns("createtime")) tag_next = "<a href=""" & tag_next & """>" & ns(0) & "</a>" else tag_next = "没有了" end if ns.close template = replace(template, match.value, tag_next) end select next end function public function parser_sys() dim sysv reg.pattern = "{sys:(.+?)}" set matches = reg.execute(template) for each match in matches if len(replace(match.submatches(0)," ","")) > 0 then execute("sysv = " & replace(match.submatches(0)," ","")) template = replace(template, match.value, sysv) end if next end function public function parser_tag(byval stemp,byval stag,byval rs) dim cmd,i,val,fun,funcmd,temp if stag = "[]" then reg.pattern = "\[field:(.+?)\]" else reg.pattern = "{field:(.+?)}" end if set matches = reg.execute(stemp) for each match in matches if len(match.submatches(0)) > 0 then cmd = split(match.submatches(0),";") val = lcase(replace(cmd(0)," ","")) select case val case "titlex" ' 加属性的标题 val = trim(rs("title")) if len(rs("style")) > 0 then val = "<"&rs("style")&">" & val & "</"&rs("style")&">" if len(rs("color")) > 0 then val = "<font color=" & rs("color") & ">" & val & "</font>" case "aurl" ' 文章页链接 'val = rs("filepath") val = articlerule(rs("aid"),rs("cid"),rs("diyname"),rs("createtime")) case "curl" ' 列表页首页 val = getcache("class." & rs("cid") & ".listrule") val = replace(val,"{cid}",rs("cid")) val = replace(val,"{page}",1) case "cnamex" val = getcache("class." & rs("cid") & ".cname") case "cname" val = splithtml(getcache("class." & rs("cid") & ".cname")) case "date" val = rs("createtime") case "i" val = session("i") case else val = rs(val) end select for i = 1 to ubound(cmd) if lcase(left(cmd(i),9)) = "function=" then fun = right(cmd(i) , len(cmd(i)) - 9) fun = left(fun, len(fun)-1) fun = split(fun,"(") funcmd = fun(1) select case lcase(replace(fun(0)," ","")) case "strlen" temp = funcmd temp = leftx(val,temp,"") case "replace" funcmd = split(funcmd,",") temp = replace(val,funcmd(0),funcmd(1)) case "strdate" temp = funcmd temp = replace(temp,"yyyy",year(val)) : temp = replace(temp,"yyy",right(year(val),3)) temp = replace(temp,"yy",right(year(val),2)) : temp = replace(temp,"y",right(year(val),1)) temp = replace(temp,"mm",right("0" & month(val),2)) : temp = replace(temp,"m",month(val)) temp = replace(temp,"dd",right("0" & day(val),2)) : temp = replace(temp,"d",day(val)) temp = replace(temp,"hh",right("0" & hour(val),2)) : temp = replace(temp,"h",hour(val)) temp = replace(temp,"mm",right("0" & minute(val),2)) : temp = replace(temp,"m",minute(val)) temp = replace(temp,"ss",right("0" & second(val),2)) : temp = replace(temp,"s",second(val)) end select val = temp end if next stemp = replace(stemp, match.value, val) end if Next parser_tag = stemp end function public function parser_comm() dim match,mathches dim backv reg.pattern = "<!--Start:\{(.+?)\}-->([\s\S]*?)<!--End-->" set matches = reg.execute(template) for each match in matches backv = parser_comm_do(match.submatches(0),match.submatches(1)) template = replace(template, match.value, backv) Next 'die end function public function parser_comm_do(byval where,byval stemp) 'dim i,tags 'dim rs,sql,sql_row,sql_table,sql_where,sql_order,sql_keywords 'dim tmep,titlelen,title,url where = split(where, ";") for i = 0 to ubound(where) tags = replace(replace(where(i),"""",""),"'","") if len(replace(tags," ","")) = 0 then parser_comm_do = "" : exit function tags = split(where(i),":") 'echo ubound(tags) & getbr select case replace(lcase(tags(0))," ", "") case "row" : sql_row = replace(tags(1)," ","") case "table" : sql_table = tags(1) case "where" : sql_where = tags(1) case "order" : sql_order = " order by " & tags(1) & " " case "keywords" : sql_keywords = replace(tags(1)," ","") end select next if not isnum(sql_row) or sql_row = "" then sql_row = 10 if sql_table = "" then sql_table = "article" if len(replace(sql_where," ","")) > 0 then sql_where = " where " & sql_where else sql_where = "" if len(sql_keywords) > 0 then sql_table = "article" if instr(sql_keywords,",") = 0 then parser_comm_do = "" : exit function dim sql_keywords_str sql_keywords = split(sql_keywords,",") for i = 0 to ubound(sql_keywords) if len(sql_keywords(i)) > 1 then if len(sql_keywords_str) = 0 then sql_keywords_str = " keywords like '%" & sql_keywords(i) & "%' " else sql_keywords_str = sql_keywords_str & " or keywords like '%" & sql_keywords(i) & "%'" end if end if next if len(sql_where) > 0 and len(sql_keywords_str) > 0 then sql_where = sql_where & " and ( " & sql_keywords_str & " )" else sql_where = " where " & sql_keywords_str end if end if sql = "select top " & sql_row & " * from " & sql_table & " " & sql_where & sql_order 'echo sql &getbr if len(getcache(sql))=0 then i = 0 : sql_row = int(sql_row) set rs = u.db(sql,1) session("i") = 0 do while not rs.eof i = i + 1 if i > sql_row then exit do session("i") = session("i") + 1 temp = parser_tag(stemp,"[]",rs) parser_comm_do = parser_comm_do & temp rs.movenext loop rs.close setcache sql,parser_comm_do else parser_comm_do = getcache(sql) end if end function %>